QBasic & Borland Pascal & C/Delphi5.iso/Basic/Visual Basic.60/COMMON/TOOLS/VB/OLEMSG/TIMECARD.CLI/CLIENT/REPORT.FRM

Visual Basic Form | 1996-06-15 | 16.4 KB | 553 lines

VERSION 5.00
Begin VB.Form formReport
   Caption         =   "Time Report Form"
   ClientHeight    =   5295
   ClientLeft      =   930
   ClientTop       =   2175
   ClientWidth     =   10485
   Height          =   5700
   Left            =   870
   LinkTopic       =   "Form1"
   ScaleHeight     =   5295
   ScaleWidth      =   10485
   Top             =   1830
   Width           =   10605
   Begin VB.TextBox txtTo
      Height          =   288
      Left            =   1080
      TabIndex        =   25
      Top             =   120
      Width           =   5052
   End
   Begin VB.TextBox txtCell
      Height          =   288
      Index           =   8
      Left            =   8760
      TabIndex        =   24
      Top             =   2160
      Width           =   972
   End
   Begin VB.TextBox txtCell
      Height          =   288
      Index           =   7
      Left            =   7680
      TabIndex        =   23
      Top             =   2160
      Width           =   972
   End
   Begin VB.TextBox txtCell
      Height          =   288
      Index           =   6
      Left            =   6600
      TabIndex        =   22
      Top             =   2160
      Width           =   972
   End
   Begin VB.TextBox txtCell
      Height          =   288
      Index           =   5
      Left            =   5520
      TabIndex        =   21
      Top             =   2160
      Width           =   972
   End
   Begin VB.TextBox txtCell
      Height          =   288
      Index           =   4
      Left            =   4440
      TabIndex        =   20
      Top             =   2160
      Width           =   972
   End
   Begin VB.TextBox txtCell
      Height          =   288
      Index           =   3
      Left            =   3360
      TabIndex        =   19
      Top             =   2160
      Width           =   972
   End
   Begin VB.TextBox txtCell
      Height          =   288
      Index           =   2
      Left            =   2280
      TabIndex        =   18
      Top             =   2160
      Width           =   972
   End
   Begin VB.TextBox txtCell
      Height          =   288
      Index           =   1
      Left            =   1200
      TabIndex        =   17
      Top             =   2160
      Width           =   972
   End
   Begin VB.TextBox txtCell
      Height          =   288
      Index           =   0
      Left            =   120
      TabIndex        =   14
      Top             =   2160
      Width           =   972
   End
   Begin VB.CommandButton btnClear
      Caption         =   "&Clear All"
      Height          =   372
      Left            =   8400
      TabIndex        =   5
      Top             =   120
      Width           =   852
   End
   Begin VB.CommandButton btnSend
      Caption         =   "&Send"
      Height          =   372
      Left            =   7080
      TabIndex        =   4
      Top             =   120
      Width           =   972
   End
   Begin VB.TextBox txtPayPeriod
      Height          =   288
      Left            =   7080
      TabIndex        =   16
      Top             =   960
      Width           =   2172
   End
   Begin VB.TextBox txtName
      Height          =   288
      Left            =   1080
      TabIndex        =   1
      Top             =   960
      Width           =   4452
   End
   Begin VB.Line Line2
      X1              =   0
      X2              =   9720
      Y1              =   1560
      Y2              =   1560
   End
   Begin VB.Label Label13
      Alignment       =   2  'Center
      Caption         =   "Total"
      Height          =   252
      Left            =   8880
      TabIndex        =   15
      Top             =   1800
      Width           =   732
   End
   Begin VB.Label Label12
      Alignment       =   2  'Center
      Caption         =   "Sat"
      Height          =   252
      Left            =   7800
      TabIndex        =   13
      Top             =   1800
      Width           =   732
   End
   Begin VB.Label Label11
      Alignment       =   2  'Center
      Caption         =   "Fri"
      Height          =   252
      Left            =   6720
      TabIndex        =   12
      Top             =   1800
      Width           =   732
   End
   Begin VB.Label Label10
      Alignment       =   2  'Center
      Caption         =   "Thu"
      Height          =   252
      Left            =   5640
      TabIndex        =   11
      Top             =   1800
      Width           =   732
   End
   Begin VB.Label Label9
      Alignment       =   2  'Center
      Caption         =   "Wed"
      Height          =   252
      Left            =   4560
      TabIndex        =   10
      Top             =   1800
      Width           =   732
   End
   Begin VB.Label Label8
      Alignment       =   2  'Center
      Caption         =   "Tue"
      Height          =   252
      Left            =   3480
      TabIndex        =   9
      Top             =   1800
      Width           =   732
   End
   Begin VB.Label Label7
      Alignment       =   2  'Center
      Caption         =   "Mon"
      Height          =   252
      Left            =   2400
      TabIndex        =   8
      Top             =   1800
      Width           =   732
   End
   Begin VB.Label Label6
      Alignment       =   2  'Center
      Caption         =   "Sun"
      Height          =   252
      Left            =   1320
      TabIndex        =   7
      Top             =   1800
      Width           =   732
   End
   Begin VB.Label lblCategories
      Alignment       =   2  'Center
      Caption         =   "Categories"
      Height          =   252
      Left            =   240
      TabIndex        =   6
      Top             =   1800
      Width           =   852
   End
   Begin VB.Label Label4
      Caption         =   "Pay Period"
      Height          =   252
      Left            =   5880
      TabIndex        =   3
      Top             =   960
      Width           =   852
   End
   Begin VB.Label Label2
      Caption         =   "Name:"
      Height          =   252
      Left            =   120
      TabIndex        =   2
      Top             =   960
      Width           =   492
   End
   Begin VB.Line Line1
      X1              =   0
      X2              =   9720
      Y1              =   720
      Y2              =   720
   End
   Begin VB.Label Label1
      Caption         =   "To:"
      Height          =   252
      Left            =   240
      TabIndex        =   0
      Top             =   120
      Width           =   492
   End
Attribute VB_Name = "formReport"
Attribute VB_Base = "0{D624D371-C698-11CF-A520-00A0D1003923}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_TemplateDerived = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Attribute VB_Customizable = False
Const RowSize As Integer = 9
Dim objRequestMsg As Object 'the request message
Dim ReportCategories  As Variant
Dim CatNum As Integer   'number of report categories in ReportCategories
Dim PayPeriod As Date
Dim ReportData() As WeekDataType
Public Sub Init()
'if there is a request message in the inbox, show the form
If FindRequestMsg Then
    ShowReportForm
End If
End Sub
Function NumFromString(txtstr As String) As Double
If IsNumeric(txtstr) Then
    NumFromString = Val(txtstr)
    NumFromString = 0
End If
End Function
Public Function ShowReportForm() As Boolean
'if can succesfully extract necessary prop from the
'request message show the form
 On Error GoTo error_olemsg
    If objRequestMsg Is Nothing Then
        MsgBox "No  active request message"
        ShowReportForm = False
        Exit Function
    End If
    If Not ExtractProps Then
        ShowReportForm = False
        Exit Function
    End If
    formReport.Show 1

    ShowReportForm = True
    Exit Function
error_olemsg:
    MsgBox "Error " & Str(Err) & ": " & Error$(Err)
    Resume Next
End Function
Private Function ExtractProps() As Boolean
'Reads number of report categories, report categiry names
' and pay period from the reques message
Dim objFields As Object
On Error GoTo error_olemsg
If objRequestMsg Is Nothing Then
    MsgBox "no message"
    ExtractProps = False
    Exit Function
End If
'get msg's fields collection
Set objFields = objRequestMsg.Fields
If objFields Is Nothing Then
    MsgBox "Error reading request message"
    Exit Function
End If
'number of categories
CatNum = objFields.Item(NumCatPropName).Value
'report categories
ReportCategories = objFields.Item(CatPropName).Value
'pay period
PayPeriod = objFields.Item(PayPeriodPropName)
ExtractProps = True
Exit Function
error_olemsg:
    MsgBox "Error " & Str(Err) & ": " & Error$(Err)
    ExtractProps = False
    Exit Function
End Function
Private Function FindRequestMsg() As Boolean
'finds request message in the inbox
'(request message has message class RequestMsgType)
'RequestMsgType is a const defined in tmcrdcmn.bas
'This functon doesn't deal very well with the situation when
'there are more than one request message in the inbox,
'It just gets the one returned by Inbox.Messges.GetFirst(RequestMsgType)
'This can be changed to showing the listbox with all the request messages
'and letting user choose the one he/she wants to user
On Error GoTo error_olemsg
Dim objInbox As Object
Dim objMessages As Object
Dim objMessage As Object
    If objSession Is Nothing Then
        MsgBox "Not logged on"
        FindRequestMsg = False
        Exit Function
    End If
    'get the inbox
    Set objInbox = objSession.Inbox
    If objInbox Is Nothing Then
        MsgBox "Failed to open Inbox"
        FindRequestMsg = False
        Exit Function
    End If
    'get the inbox's message collection
    Set objMessages = objInbox.Messages
    If objMessages Is Nothing Then
        MsgBox "Failed to open folder's Messages collection"
        FindRequestMsg = False
        Exit Function
    End If
    Set objMessage = objMessages.GetFirst(RequestMsgType)
    If objMessage Is Nothing Then
        MsgBox "no request msg found"
        FindRequestMsg = False
        Exit Function
    End If
    Set objRequestMsg = objMessage

    FindRequestMsg = True
    Exit Function
error_olemsg:
    MsgBox "Error " & Str(Err) & ": " & Error$(Err)
    Resume Next
End Function
Private Sub ShowGrid()
'displays the a appropriate number of edit boxes
'on the form
Const initX As Integer = 120
Const initY As Integer = 2160
Const deltaX As Integer = 1080
Const deltaY As Integer = 600
Dim row As Integer
Dim col As Integer
Dim ind As Integer
For row = 1 To CatNum - 1
    For col = 1 To RowSize
        ind = row * RowSize + col - 1
        Load txtCell(ind)
        txtCell(ind).Top = initY + row * deltaY
        txtCell(ind).Left = initX + (col - 1) * deltaX
        txtCell(ind).Visible = True
    Next col
Next row
For row = 0 To CatNum - 1
    txtCell(row * RowSize).Text = ReportCategories(row)
    txtCell(row * RowSize).Enabled = False
    txtCell((row + 1) * RowSize - 1).Enabled = False
Next row
End Sub
Function SumUpRow(RowNum As Integer) As Double
Dim ind As Integer
Dim total As Double
total = 0
For ind = 1 To RowSize - 2 Step 1
    total = total + NumFromString(txtCell.Item((RowNum - 1) * RowSize + ind).Text)
Next ind
SumUpRow = total
End Function
Private Sub btnClear_Click()
Dim row As Integer
Dim col As Integer
Dim ind As Integer
For row = 0 To CatNum - 1 Step 1
    For col = 2 To RowSize
        ind = row * RowSize + col - 1
        txtCell(ind).Text = ""
    Next col
Next row
End Sub
Private Sub btnSend_Click()
'generates and sends a report message
On Error GoTo error_olemsg
Dim objReportMsg As Object
Dim obj As Object
Dim objR As Object
Dim prop As Object
Dim objFields As Object
Dim PropName As String
Dim row As Integer
Dim col As Integer
Dim ind As Integer
MousePointer = WaitCursor
ReDim ReportData(CatNum)
Dim dbgstr As String
dbgstr = ""
'get the data
For row = 0 To CatNum - 1 Step 1
    For col = 2 To RowSize - 1 'don't need total
        ind = row * RowSize + col - 1
        ReportData(row).Day(col - 2) = NumFromString(txtCell(ind).Text)
        dbgstr = dbgstr & ReportData(row).Day(col - 2) & " "
    Next col
    Debug.Print dbgstr
    dbgstr = ""
Next row
If objSession Is Nothing Then
    MsgBox "Not logged on"
    Exit Sub
End If
'create a new message in the outbox
Set objReportMsg = objSession.Outbox.Messages.Add
If objReportMsg Is Nothing Then
    MsgBox "Can't add a prop"
    Exit Sub
End If
'set the message class
objReportMsg.Type = ReportMsgType
'address the message to the sender of the request message
Set objR = objReportMsg.Recipients.Add(EntryId:=objRequestMsg.Sender.ID, _
                                        Name:=objRequestMsg.Sender.Name)
If objR Is Nothing Then
    MsgBox "Can't set recipient"
    Exit Sub
End If
'get msg field collection
Set objFields = objReportMsg.Fields
If objFields Is Nothing Then
    MsgBox "Internal error. (can't access msg's field collecton)"
    Exit Sub
End If
'report data is transmitted in named properties.
'name for the property containing data for the i-th category is "i"
'i = 1, 2, ..., NumberOfCategories
For row = 1 To CatNum Step 1
    PropName = RepDataPropPrefix & Str(row)
    'we can't write:
    'Set obj = objFields.Add(Name:=PropName, _
                             Class:=vbDouble + vbArray, _
                             Value:=ReportData(row - 1.Day)
    'because of the way VB passes array parameters
    'so we first add a property and then set its value
    Set obj = objFields.Add(Name:=PropName, _
                                    Class:=vbDouble + vbArray)
    If obj Is Nothing Then
        MsgBox "Can't add a prop"
        Exit Sub
    End If
    obj.Value = ReportData(row - 1).Day
Next row
Set obj = objFields.Add(Name:=CatPropName, _
                                    Class:=vbString + vbArray)
If obj Is Nothing Then
        MsgBox "Can't add a prop"
        Exit Sub
    End If
obj.Value = ReportCategories
Set obj = objFields.Add(Name:=NumCatPropName, _
            Class:=vbInteger, _
            Value:=CatNum)
If obj Is Nothing Then
        MsgBox "Can't add a prop"
        Exit Sub
End If
Set prop = objFields.Add(Name:=PayPeriodPropName, _
            Class:=vbDate, _
            Value:=PayPeriod)
If prop Is Nothing Then
        MsgBox "Can't add a prop"
        Exit Sub
End If
'$for testing only, later this field (txtName)
'will be read-only
'Set obj = objFields.Add(Name:=NamePropName, _
            Class:=vbString, _
            Value:=txtName.Text)
'If obj Is Nothing Then
'        MsgBox "Can't add a prop"
'        Exit Sub
'End If
objReportMsg.Send showDialog:=False
MousePointer = DefaultCursor
Unload Me
Exit Sub
error_olemsg:
    MsgBox "Error " & Str(Err) & ": " & Error$(Err)
    Resume Next
End Sub
Private Sub Categories_Click()
End Sub
Private Sub Form_Load()
    txtTo.Text = objRequestMsg.Sender.Name
    txtTo.Enabled = False
    txtName.Text = objSession.CurrentUser.Name
    txtName.Enabled = False
    txtPayPeriod.Text = PayPeriod
    txtPayPeriod.Enabled = False
    ShowGrid
End Sub
Private Sub Form_Unload(Cancel As Integer)
    CatNum = 0
    Set objRequestMsg = Nothing
End Sub
Private Sub txtCell_LostFocus(Index As Integer)
'do some validation
Dim indTot As Integer
    If (Index Mod RowSize = 0) Or ((Index + 1) Mod RowSize = 0) Then
        Debug.Print "LostFocus from a disable control"
        Exit Sub
    End If
    If txtCell.Item(Index).Text = "" Then
        Exit Sub
    End If
    If IsNumeric(txtCell.Item(Index).Text) And _
        Val(txtCell.Item(Index).Text) >= 0 And _
        Val(txtCell.Item(Index).Text) <= 24 Then

        indTot = (Index \ RowSize) * RowSize + RowSize - 1
        txtCell.Item(indTot).Text = SumUpRow(Index \ RowSize + 1)
    Else
        MsgBox "Has to be number of hours." + Chr(13) + _
                "(Can not be greater than 24)"
        txtCell(Index).SetFocus
    End If
End Sub